home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / FMONITR.R < prev    next >
Encoding:
Text File  |  1992-02-10  |  30.4 KB  |  1,203 lines
  1. /*
  2.  *  fmonitor.r -- mmout, mmpause, mmshow, EvSetup, EvSelect, EvGet
  3.  *
  4.  *   This file contains event monitoring code.
  5.  *
  6.  *   Much of this code is contingent on the definition of MemMon (memory
  7.  *   monitoring) and EventMon (event monitoring). Memory monitoring came
  8.  *   first and normally is defined in all implementations of Icon. It also
  9.  *   is a supported feature with various visualization tools. (See the
  10.  *   directory "memmon", which is parallel to this one.) Event monitoring is
  11.  *   more recent and is stil experimental. It normally is not enabled. Memory
  12.  *   monitoring is a subset of event monitoring.
  13.  *
  14.  *   When MemMon or EventMon is undefined, most of the "MMxxxx" and "EVxxxx"
  15.  *   entry points are defined as null macros in monitor.h.
  16.  *
  17.  *   See monitor.h for important definitions and for the interaction between
  18.  *   MemMon and Eventmon.
  19.  */
  20.  
  21.  
  22. #ifdef MemMon
  23.  
  24. /*
  25.  * Prototypes.
  26.  */
  27.  
  28. hidden    novalue evcmd        Params((word addr, word len, int c));
  29. hidden    novalue evdec        Params((uword n));
  30. hidden    novalue evforget    Params((noargs));
  31. hidden    novalue etvalue        Params((word n, int c));
  32.  
  33. #ifdef EventMon
  34. hidden    novalue etqvalue    Params((word n, int c));
  35. int    evstring    Params((char *buf, int buflen, int tc));
  36. #endif                    /* EventMon */
  37.  
  38. hidden    novalue evnewline    Params((noargs));
  39. hidden    novalue mmrefresh    Params((noargs));
  40. hidden    novalue mmsizes        Params((int c));
  41. hidden    novalue mmstatic    Params((noargs));
  42.  
  43. FILE *monfile = NULL;        /* output file pointer */
  44.  
  45. static char *monname = NULL;    /* output file name */
  46.  
  47. #ifdef EventMon
  48. union {             /* clock ticker -- keep in sync w/ interp.c */
  49.    unsigned short s[4];        /* four counters */
  50.    unsigned long l[2];        /* two longs are easier to check */
  51. } ticker;
  52. unsigned long oldtick;        /* previous sum of the two longs */
  53. #endif                    /* EventMon */
  54.  
  55. static word llen = 0;        /* current output line length */
  56.  
  57. static char typech[MaxType+1];    /* output character for each type */
  58.  
  59. /* Define size of curvalue table, and bias needed to access it. */
  60. /* Assumes all type codes are printable characters (or space).   */
  61. /* Smaller table is used if not EBCDIC.                          */
  62. #if !EBCDIC
  63. #define CurSize (127 - ' ')
  64. #define CurBias ' '
  65. #else                    /* !EBCDIC */
  66. #define CurSize 256
  67. #define CurBias 0
  68. #endif                    /* !EBCDIC */
  69.  
  70. static word curvalue[CurSize];    /* current length for each output character */
  71.  
  72. /* line limit: start a new line when a command goes beyond this column */
  73. #define LLIM 70
  74.  
  75. /* evchar(c): output character c and update the column counter */
  76. #define evchar(c) (llen++,putc((c),monfile))
  77.  
  78. /* evspace(): output unneeded whitespace whitespace following a command */
  79. /*  define as "evchar(' ')" for readable files, or as "0" for compact ones */
  80. #define evspace() 0
  81.  
  82. /*
  83.  * evseparate(): output either a space or a newline depending on spacing
  84.  *  requirements
  85.  */
  86. #define evseparate() if (llen >= LLIM) evnewline(); else evchar(' ');
  87.  
  88.  
  89. "mmout(s) - write the given string to the MemMon file."
  90.  
  91. function{1} mmout(s)
  92.    if !def:C_string(s, "") then
  93.       runerr(103, s)
  94.    abstract {
  95.       return null
  96.       }
  97.    inline {
  98.       MMOut("", s);
  99.       return nulldesc;
  100.       }
  101. end
  102.  
  103.  
  104. "mmpause(s) - pause MemMon displaying string s."
  105.  
  106. function{1} mmpause(s)
  107.    if !def:C_string(s, "") then
  108.       runerr(103, s)
  109.    abstract {
  110.       return null
  111.       }
  112.    inline {
  113.       MMOut("; ", s[0] ? s : "programmed pause");
  114.       return nulldesc;
  115.       }
  116. end
  117.  
  118.  
  119. "mmshow(x,s) - alter MemMon display of x depending on s."
  120.  
  121. function{1} mmshow(x, s)
  122.  
  123.    if !def:string(s, emptystr) then
  124.       runerr(103, s)
  125.    abstract {
  126.       return null
  127.       }
  128.    body {
  129.       register word i, j, d;
  130.       register union block *bp, *ep;
  131.       char c;
  132.       struct b_slots *seg;
  133.  
  134.       if (StrLen(s) == 0)
  135.      c = '\0';
  136.       else
  137.      c = *StrLoc(s);
  138.       MMShow(&x,c);
  139.       switch (Type(x)) {
  140.       case T_List:
  141.             bp = BlkLoc(x);
  142.             for (bp = bp->list.listhead; bp != NULL; bp = bp->lelem.listnext) {
  143.            x.dword = D_Lelem;
  144.                BlkLoc(x) = bp;
  145.                MMShow(&x, c);
  146.                }
  147.         break;
  148.       case T_Set:
  149.       case T_Table:
  150.         d = (Type(x) == T_Set) ? D_Selem : D_Telem;
  151.             bp = BlkLoc(x);
  152.             for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++) {
  153.            x.dword = D_Slots;
  154.                BlkLoc(x) = (union block *)seg;
  155.                MMShow(&x, c);
  156.                for (j = segsize[i] - 1; j >= 0; j--) {
  157.               x.dword = d;
  158.                   for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink) {
  159.                      BlkLoc(x) = ep;
  160.                      MMShow(&x, c);
  161.                      }
  162.                   }
  163.                }
  164.             break;
  165.          }
  166.  
  167.       return nulldesc;
  168.       }
  169. end
  170.  
  171. #ifdef EventProc
  172. /*
  173.  * EvSetup, EvSelect, EvGet - user functions for reading event streams.
  174.  */
  175. FILE *evfile;        /* input file */
  176.  
  177. word evctx;        /* current event context */
  178. word wantctx = 1;    /* nonzero if this context is selected */
  179. word evdepth;        /* current nesting depth */
  180. word evstk[MaxEvNest+1];    /* nesting stack */
  181.  
  182. int nevsel;        /* number of event contexts */
  183. char *evsel;        /* nonzero entry for each context selected */
  184.  
  185. word evhist[256];    /* history of previous values */
  186.  
  187. dptr EvContext;        /* pointer to EvContext global */
  188. dptr EvCode;        /* pointer to EvCode global */
  189. dptr EvValue;        /* pointer to EvValue global */
  190. dptr EvGivenValue;    /* pointer to EvGivenValue global */
  191.  
  192. /*
  193.  * MT code is written as if there were a global variable EStream:
  194.  */
  195. #ifdef MultiThread
  196. dptr EStream;        /* pointer to EventStream global */
  197. #endif            /* MultiThread */
  198.  
  199.  
  200. "EvSetup(f,i) - initialize to read event tokens from file f."
  201. /*
  202.  *  i is the highest context number that will be allowed.
  203.  *  Globals EvContext, EvCode, EvValue, and EvGivenValue must exist.
  204.  */
  205.  
  206. function{1} EvSetup(f,n)
  207.  
  208.    abstract {
  209.       return null
  210.       }
  211.  
  212.    if !is:file(f) then
  213.       runerr(105, f)
  214.  
  215.    /*
  216.     * n must be a positive integer.
  217.     */
  218.    if !cnv:C_integer(n) then
  219.       runerr(101, n)
  220.    body {
  221.       word i;
  222.       struct descrip d1, d2, d3, d4, d5;
  223.  
  224.       if (n <= 0) {
  225.          irunerr(205, n);
  226.          errorfail;
  227.          }
  228.       nevsel = n;
  229.  
  230.       /*
  231.        * Find the globals.
  232.        */
  233.       if (getvar("EvContext", &d1) != Succeeded
  234.          || getvar("EvCode", &d2) != Succeeded
  235.          || getvar("EvValue", &d3) != Succeeded
  236.          || getvar("EvGivenValue", &d4) != Succeeded)
  237.          runerr(126);
  238.       EvContext = VarLoc(d1);
  239.       EvCode = VarLoc(d2);
  240.       EvValue = VarLoc(d3);
  241.       EvGivenValue = VarLoc(d4);
  242.  
  243.       /*
  244.        * Initialize the selection table and save the file pointer.
  245.        */
  246.       evsel = (char *)malloc((msize)(nevsel + 1));
  247.       if (evsel == NULL)
  248.          runerr(305);
  249.       for (i = 0; i <= nevsel; i++)
  250.          evsel[i] = 1;
  251.  
  252.  
  253.       evfile = BlkLoc(f)->file.fd;
  254.  
  255.       return nulldesc;
  256.       }
  257. end
  258.  
  259.  
  260. "EvSelect(i1, i2,...) - configure EvGet to return only certain event contexts."
  261.  
  262. function{1} EvSelect(x[nargs])
  263.  
  264.    abstract {
  265.       return null
  266.       }
  267.    body {
  268.       register C_integer i;
  269.       C_integer j;
  270.       /*
  271.        * Be sure EvSetup was called.
  272.        */
  273.       if (evfile == NULL)
  274.          runerr(126);
  275.  
  276.       if (nargs == 0) {
  277.          /*
  278.           * With no arguments, enable all contexts.
  279.           */
  280.          for (i = 0; i <= nevsel; i++)
  281.             evsel[i] = 1;
  282.          wantctx = (evctx <= nevsel); 
  283.          return nulldesc;
  284.          }
  285.       else {
  286.          /*
  287.           * With explicit arguments, disable all contexts, then enable
  288.           * as selected.
  289.           */
  290.          for (i = 0; i <= nevsel; i++)
  291.             evsel[i] = 0;
  292.          for (i = 0; i < nargs; i++) {
  293.             if (!cnv:C_integer(x[i], j))
  294.                runerr(101, x[i]);
  295.             if (j < 0 || j > nevsel)
  296.                runerr(205, x[i]);
  297.             evsel[j] = 1;
  298.             }
  299.          wantctx = (evctx <= nevsel && evsel[evctx]); 
  300.          return nulldesc;
  301.          }
  302.       }
  303. end
  304.  
  305.  
  306. "EvGet(c) - read through the next event token having a code matched by cset c."
  307.  
  308. /*
  309.  *  EvGet returns the code of the matched token.  These globals are also set:
  310.  *    EvContext      context number
  311.  *    EvCode         token code
  312.  *    EvValue        token value, with implicit value if omitted
  313.  *    EvGivenValue   token value, &null if omitted
  314.  */
  315. function{0,1} EvGet(cs)
  316.    if !def:tmp_cset(cs,fullcs) then
  317.       runerr(104,cs)
  318.  
  319.    abstract {
  320.       return string
  321.       }
  322.    
  323.    body {
  324.       register int c;
  325.       register word n, tkctx, wanted;
  326.       char sbuf[MaxEvString];
  327.       word len;
  328.  
  329.       /*
  330.        * Be sure EvSetup was called.
  331.        */
  332.       if (evfile == NULL)
  333.          runerr(126);
  334.  
  335.       /*
  336.        * Loop until we read an event matched by the cset.
  337.        */
  338.       for (wanted = 0; !wanted; ) {
  339.          /*
  340.           * Parse the token up through the event code character.
  341.           */
  342.          tkctx = evctx;        /* context of this token */
  343.          n = -1;            /* -1 indicates no integer value */
  344.          len = -1;            /* -1 indicates no string value */
  345.  
  346.  
  347.          c = getc(evfile);
  348.          while (isspace(c))    /* skip leading whitespace */
  349.             c = getc(evfile);
  350.          if (isdigit(c)) {        /* if digit, build up count */
  351.             n = c - '0';
  352.             while (isdigit(c = getc(evfile)))
  353.                n = 10 * n + c - '0';
  354.             }
  355.          else if (c == '"') {    /* if quote, read string value */
  356.             len = evstring (sbuf, MaxEvString, '"');
  357.             c = getc(evfile);    /* load following character */
  358.             }
  359.  
  360.          while (isspace(c))    /* skip whitespace after the value */
  361.             c = getc(evfile);
  362.  
  363.  
  364.          /*
  365.           * Handle according to the code character now in c.
  366.           *  Decide whether the event is wanted.
  367.           */
  368.          switch (c) {
  369.             case EOF:
  370.                *EvContext = *EvCode = *EvValue = *EvGivenValue = nulldesc;
  371.                fail;
  372.             case E_Comment:
  373.             case E_Pause:
  374.                len = evstring (sbuf, MaxEvString, '\n');
  375.                wanted = wantctx && Testb(c, cs);
  376.                break;
  377.             case E_Start:            /* start (push) context */
  378.                if (evdepth < MaxEvNest)
  379.                   evstk[++evdepth] = evctx = tkctx = n;
  380.                wantctx = (evctx <= nevsel && evsel[evctx]);
  381.                wanted = wantctx && Testb(c, cs);
  382.                break;
  383.             case E_End:            /* end (pop) context */
  384.                wanted = wantctx && Testb(c, cs);
  385.                if (evstk[evdepth] == n && evdepth > 0)
  386.                   evctx = evstk[--evdepth];
  387.                wantctx = (evctx <= nevsel && evsel[evctx]);
  388.                break;
  389.             default:
  390.                wanted = wantctx && Testb(c, cs);
  391.                break;
  392.             }
  393.          }
  394.  
  395.       /*
  396.        * This event is wanted.  Set the globals and return.
  397.        */
  398.       MakeInt(tkctx, EvContext);
  399.  
  400.       if (len >= 0) {        /* if quoted value given */
  401.          StrLen(*EvGivenValue) = len;
  402.          Protect(StrLoc(*EvGivenValue) = alcstr(sbuf, len), runerr(0));
  403.          *EvValue = *EvGivenValue;    /* store in EvGivenValue and EvValue */
  404.          }
  405.       else if (n >= 0) {        /* if numeric value given */
  406.          evhist[c] = n;        /* remember it */
  407.          MakeInt(n, EvGivenValue);    /* store in EvGivenValue and EvValue */
  408.          *EvValue = *EvGivenValue;
  409.          }
  410.       else {            /* if no value */
  411.          *EvGivenValue = nulldesc;    /* set EvGivenValue to null */
  412.          MakeInt(evhist[c], EvValue);  /* store previous value as EvValue */
  413.          }
  414.  
  415.       StrLen(*EvCode) = 1;
  416.       StrLoc(*EvCode) = &allchars[FromAscii(c) & 0xFF];
  417.       return *EvCode;
  418.       }
  419. end
  420.  
  421. /*
  422.  * evstring (buf, buflen, tc) - read event string into buf.
  423.  *
  424.  *  Characters from the event stream are read until the terminator character
  425.  *  tc is read.  The characters excluding the terminator are stored in the
  426.  *  buffer buf of length buflen; excess characters are discarded.  The number
  427.  *  of characters stored is returned.
  428.  */
  429. int evstring (buf, buflen, tc)
  430. char *buf;
  431. int buflen, tc;
  432.    {
  433.    register int c;
  434.    register word n;
  435.  
  436.    n = 0;
  437.    while ((c = getc(evfile)) != tc && c != EOF)
  438.       if (n < buflen)
  439.          buf[n++] = c;
  440.    return n;
  441.    }
  442. #endif                    /* EventProc */
  443.  
  444. /*
  445.  *  EVInit(exename,outname) - initialization.
  446.  *
  447.  *  Event monitoring is activated if one of the environment variables EVENTMON
  448.  *  or MEMMON is non-null, depending on which type of monitoring is configured.
  449.  *  The environment variable names the output file;  or, under implementations
  450.  *  that support pipes, a value beginning with "|" specifies a command to which
  451.  *  the output is piped.
  452.  *
  453.  *  Monitoring can also be activated by the -E option on the iconx command
  454.  *  line, in which case outname is nonnull and overrides any environment
  455.  *  setting.
  456.  *
  457.  *  If monitoring is defined on a system lacking environment variables,
  458.  *  monitoring is always activated and output is to the file "eventmon.out"
  459.  *  if outname does not specify a different file.
  460.  */
  461.  
  462. novalue EVInit(exename,outname)
  463. char *exename;
  464. char *outname;
  465.    {
  466.    int i;
  467.    FILE *f;
  468.    char time_buf[26];
  469.  
  470. #ifdef EventMon
  471.    char *name = EVENTMON;
  472. #else                    /* EventMon */
  473.    char *name = MEMMON;
  474. #endif                    /* EventMon */
  475.  
  476.  
  477.    /*
  478.     * Initialize the typech array, which is used if either file-based
  479.     * or MT-based event monitoring is enabled.
  480.     */
  481.  
  482.    for (i = 0; i <= MaxType; i++)
  483.       typech[i] = '?';    /* initialize with error character */
  484.  
  485. #ifdef LargeInts
  486.    typech[T_Lrgint]  = E_Lrgint;    /* long integer */
  487. #endif                    /* LargeInts */
  488.  
  489.    typech[T_Real]    = E_Real;        /* real number */
  490.    typech[T_Cset]    = E_Cset;        /* cset */
  491.    typech[T_File]    = E_File;        /* file block */
  492.    typech[T_Record]  = E_Record;    /* record block */
  493.    typech[T_Tvsubs]  = E_Tvsubs;    /* substring trapped variable */
  494.    typech[T_External]= E_External;    /* external block */
  495.    typech[T_List]    = E_List;        /* list header block */
  496.    typech[T_Lelem]   = E_Lelem;        /* list element block */
  497.    typech[T_Table]   = E_Table;        /* table header block */
  498.    typech[T_Telem]   = E_Telem;        /* table element block */
  499.    typech[T_Tvtbl]   = E_Tvtbl;        /* table elem trapped variable*/
  500.    typech[T_Set]     = E_Set;        /* set header block */
  501.    typech[T_Selem]   = E_Selem;        /* set element block */
  502.    typech[T_Slots]   = E_Slots;        /* set/table hash slots */
  503.    typech[T_Coexpr]  = E_Coexpr;    /* co-expression block (static) */
  504.    typech[T_Refresh] = E_Refresh;    /* co-expression refresh block */
  505.  
  506.    /*
  507.     * codes used elsewhere but not shown here:
  508.     *    in the static region: E_Alien = alien (malloc block)
  509.     *    in the static region: E_Free = free
  510.     *    in the string region: E_String = string
  511.     */
  512.  
  513.  
  514.    /*
  515.     * Now, if file-based event monitoring is desired, turn it on.
  516.     * Look up the MEMMON/EVENTMON environment variable if outname is NULL.
  517.     */
  518.  
  519.    if (outname)
  520.       monname = outname;
  521.    else {
  522.  
  523. #ifdef EnvVars
  524.       monname = getenv(name);
  525.       if (monname == NULL || strlen(monname) == 0)
  526.          return;
  527. #else                    /* EnvVars */
  528.       monname = "monitor.out";
  529. #endif                    /* EnvVars */
  530.  
  531.       }
  532.  
  533. #ifdef Pipes
  534.    if (monname[0] == '|')
  535.       f = popen(monname+1, WriteText);
  536.    else
  537. #endif                    /* Pipes */
  538.  
  539.       {
  540.       if (monname[0] == '-' && monname[1] == '\0')
  541.          f = stdout;
  542.       else
  543.          f = fopen(monname, WriteText);
  544.       }
  545.  
  546.    if (f == NULL) {
  547.       fprintf(stderr, "%s: cannot open %s\n", name, monname);
  548.       fflush(stderr);
  549.       exit(ErrorExit);
  550.       }
  551.  
  552.  
  553. #ifdef EventMon
  554. #if UNIX
  555.    /*
  556.     * Call profil(2) to enable program counter profiling.  We use the smallest
  557.     *  allowable scale factor in order to minimize the number of counters;
  558.     *  we assume that the text of iconx does not exceed 256K and so we use
  559.     *  four bins.  One of these four bins will be incremented every system
  560.     *  clock tick (typically 4 to 20 ms).
  561.     *
  562.     *  Take your local profil(2) man page with a grain of salt.  All the systems
  563.     *  we tested really maintain 16-bit counters despite what the man pages say.
  564.     *  Some also say that a scale factor of two maps everything to one counter;
  565.     *  that is believed to be a no-longer-correct statement dating from the days
  566.     *  when the maximum program size was 64K.
  567.     *
  568.     *  The reference to EVInit below just obtains an arbitrary address within
  569.     *  the text segment.
  570.     */
  571.    profil(ticker.s, sizeof(ticker.s), (int) EVInit & ~0x3FFFF, 2);
  572. #endif                    /* UNIX */
  573. #endif                    /* EventMon */
  574.  
  575.    getctime(time_buf);
  576.    fprintf(f, "##  Icon event stream, Version %s\n", Eversion);
  577.    fprintf(f, "#\n");
  578.    fprintf(f, "#   program: %s\n", exename);
  579.    fprintf(f, "#   date:    %s", time_buf);
  580.  
  581.    /*
  582.     * Set monfile to indicate that monitoring is active.  Don't set it earlier
  583.     * than this, or we'll loop trying to trace the garbage collection that
  584.     * creates the buffer space.
  585.     */
  586.    monfile = f;
  587.    }
  588.  
  589. /*
  590.  *  EVSetup() - Set up storage information.
  591.  */
  592. novalue EVSetup()
  593.    {
  594.  
  595.    if (!EventStream)
  596.       return;
  597.    mmrefresh();                /* show current state */
  598.    fflush(monfile);            /* force it out */
  599.    }
  600.  
  601. /*
  602.  * EVTerm(n, part2) - terminate memory monitoring.
  603.  *  The error message for n and part2 are concatentated to form an explanatory
  604.  *  message.
  605.  */
  606.  
  607. novalue EVTerm(n, part2)
  608. int n;
  609. char *part2;
  610.    {
  611.    FILE *f;
  612.    char part1[40];
  613.  
  614.    if (!EventStream)
  615.       return;
  616.    if (n > 0)
  617.       sprintf(part1,"Run-time error %d: ",n);
  618.    else
  619.       part1[0] = '\0';
  620.    if (part2 == NULL)
  621.       part2 = "";
  622.    evnewline();
  623.    mmsizes('=');        /* make a final check on region sizes */
  624.  
  625. #ifdef EventMon
  626.    EVVal(C_Eval,E_End);
  627.    fprintf(monfile,"\n");
  628. #endif                    /* EventMon */
  629.  
  630.    if (*part1 || *part2)    /* if any reason given, write it as comment */
  631.       fprintf(monfile, "# %s%s\n", part1, part2);
  632.  
  633.    f = monfile;
  634.    monfile = NULL;    /* so we don't try to show the freeing of the buffer */
  635.  
  636. #ifdef Pipes
  637.    if (monname[0] == '|')
  638.       pclose(f);
  639.    else
  640. #endif                    /* Pipes */
  641.       fclose(f);
  642.    }
  643.  
  644. /*
  645.  * MMStat(a, n, c) - note static block at a, length n, represented by char 'c'.
  646.  * Output values are in basic units (typically words).
  647.  */
  648. novalue MMStat(a, n, c)
  649. char *a;
  650. word n;
  651. int c;
  652.    {
  653.  
  654. #ifndef FixedRegions
  655.    if (!EventStream)
  656.       return;
  657.    evcmd(DiffPtrs(a, statbase) / MMUnits, n / MMUnits, c);
  658. #endif                    /* FixedRegions */
  659.  
  660.    }
  661.  
  662. /*
  663.  * MMAlc(len, type) - note an allocation at the end of the block region.
  664.  *
  665.  *  If len is negative, it's a deallocation, and the type doesn't matter.
  666.  */
  667.  
  668. novalue MMAlc(len, type)
  669. word len;
  670. int type;
  671.    {
  672.    if (len < 0)
  673.       evcmd((word)-1, -len / MMUnits, E_BlkDeAlc);
  674.    else
  675.       EVVal(len / MMUnits, typech[type]);
  676.    }
  677.  
  678. /*
  679.  * MMStr(len) - note a string allocation at the end of the string region.
  680.  *
  681.  *  If len is negative, it's a deallocation.
  682.  */
  683.  
  684. novalue MMStr(slen)
  685. word slen;
  686.    {
  687.    if (slen > 0)
  688.       EVVal(slen, E_String);
  689.    else if (slen < 0)
  690.       evcmd((word)-1, -slen, E_StrDeAlc);
  691.    }
  692.  
  693. /*
  694.  * MMBGC() - begin garbage collection.
  695.  */
  696.  
  697. novalue MMBGC(region)
  698. int region;
  699.    {
  700.    if (!EventStream)
  701.       return;
  702.  
  703.    mmsizes('=');            /* write current sizes */
  704.  
  705. #ifdef EventMon
  706.    EVVal(C_Collect,E_Start);
  707.    EVVal(region, E_Region);
  708.    EVVal(C_Mark,E_Start);
  709.    llen += 7;
  710. #else                    /* EventMon */
  711.    fprintf(monfile, "%d{\n", region);    /* indicate start of g.c. */
  712. #endif                    /* EventMon */
  713.  
  714.    fflush(monfile);
  715.    evforget();                /* clear memory of block sizes */
  716.    }
  717.  
  718. /*
  719.  * MMEGC() - end garbage collection.
  720.  */
  721.  
  722. novalue MMEGC()
  723.    {
  724.    if (!EventStream)
  725.       return;
  726.    evnewline();
  727.  
  728. #ifdef EventMon
  729.    EVVal(C_Mark, E_End);
  730. #else                    /* EventMon */
  731.    fprintf(monfile, "}\n");    /* indicate end of marking */
  732. #endif                    /* EventMon */
  733.  
  734.    mmrefresh();            /* redraw regions after compaction */
  735.  
  736. #ifdef EventMon
  737.    EVVal(C_Collect, E_End);        /* indicate end of g.c. */
  738. #else                    /* EventMon */
  739.    fprintf(monfile, "!\n");    /* indicate end of g.c. */
  740. #endif                    /* EventMon */
  741.  
  742.    fflush(monfile);
  743.    }
  744.  
  745. /*
  746.  * MMMark(block, type) - mark indicated block during garbage collection.
  747.  */
  748.  
  749. novalue MMMark(block, type)
  750. char *block;
  751. int type;
  752.    {
  753.    if (!EventStream)
  754.       return;
  755.    evcmd(DiffPtrs(block, blkbase) / MMUnits, (word)BlkSize(block) / MMUnits,
  756.       typech[type]);
  757.    }
  758.  
  759. /*
  760.  * MMSMark - Mark String.
  761.  */
  762.  
  763. novalue MMSMark(saddr, slen)
  764. char *saddr;
  765. word slen;
  766.    {
  767.    if (!EventStream)
  768.       return;
  769.    evcmd(DiffPtrs(saddr, strbase), slen, E_String);
  770.    }
  771.  
  772. /*
  773.  * MMOut(prefix, msg) - write the prefix and message to the MemMon output file.
  774.  */
  775.  
  776. novalue MMOut(prefix, msg)
  777. char *prefix, *msg;
  778.    {
  779.    if (!EventStream)
  780.       return;
  781.    evnewline();
  782.    fprintf(monfile, "%s%s\n", prefix, msg);
  783.    }
  784.  
  785. /*
  786.  * MMShow(d, colr) - redraw string or block d, specifying the color character.
  787.  */
  788.  
  789. novalue MMShow(d, colr)
  790. dptr d;
  791. int colr;
  792.    {
  793.    char *block;
  794.    uword addr;
  795.    word len;
  796.    char cmd, tch;
  797.  
  798.    if (!EventStream)
  799.       return;
  800.    if (colr == '\0')
  801.       colr = 'r';        /* default color is 'r' (redraw) */
  802.  
  803.    if (Qual(*d)) {
  804.       /*
  805.        *  Show a string.
  806.        */
  807.       if (!InRange(strbase,StrLoc(*d),strend))
  808.          return;    /* ignore if outside string region */
  809.       addr = DiffPtrs(StrLoc(*d), strbase);
  810.       len = StrLen(*d);
  811.       cmd = '$';
  812.       tch = E_String;
  813.       }
  814.    else if (Type(*d)==T_Coexpr) {
  815.       /*
  816.        *  Show a co-expression block, which will be in the static region.
  817.        */
  818.       block = (char *)BlkLoc(*d);
  819.       addr = DiffPtrs(block, statbase) / MMUnits;
  820.       len = BlkSize(block) / MMUnits;
  821.       cmd = 'Y';
  822.       tch = typech[T_Coexpr];
  823.       }
  824.    else if (Pointer(*d)) {
  825.       /*
  826.        *  Show object in the block region.
  827.        */
  828.       block = (char *)BlkLoc(*d);
  829.       if (!InRange(blkbase,block,blkfree))
  830.          return;    /* ignore if outside block region */
  831.       addr = DiffPtrs(block, blkbase) / MMUnits;
  832.       len = BlkSize(block) / MMUnits;
  833.       cmd = '%';
  834.       tch = typech[Type(*d)];
  835.       }
  836.  
  837.    if (llen+5 >= LLIM)        /* allow extra room; this will be a long one */
  838.       evnewline();
  839.  
  840.    evdec(addr);            /* address */
  841.    evchar(E_Offset);
  842.  
  843. #ifdef EventMon
  844.    evchar('"');
  845. #endif                    /* EventMon */
  846.  
  847.    etvalue(len, cmd);        /* length, and $ Y or % command */
  848.    evchar(colr);        /* color flag */
  849.    evchar(tch);            /* block type character */
  850.  
  851. #ifdef EventMon
  852.    evchar('"');
  853.    evchar(E_Highlight);
  854. #endif                    /* EventMon */
  855.  
  856.    if (llen >= LLIM)
  857.       evnewline();
  858.    else
  859.       evspace();
  860.    }
  861.  
  862. /*
  863.  * mmrefresh() - redraw screen, initially or after garbage collection.
  864.  */
  865.  
  866. static novalue mmrefresh()
  867.    {
  868.    char *p;
  869.    word n;
  870.  
  871.    evnewline();
  872.    mmsizes('<');            /* signal start of screen refresh */
  873.    evnewline();
  874.    evforget();                /* clear memory of past sizes */
  875.    mmstatic();                /* show the static region */
  876.    evnewline();
  877.    for (p = blkbase; p < blkfree; p += n)
  878.       MMAlc(n = BlkSize(p), (int)BlkType(p));/* block region */
  879.    evnewline();
  880.    MMStr(DiffPtrs(strfree, strbase));    /* string region */
  881.    evnewline();
  882.  
  883. #ifdef EventMon
  884.    EVVal(C_Redraw, E_End);        /* signal redrawing */
  885. #else                    /* EventMon */
  886.    fprintf(monfile, ">\n");        /* signal end of refresh */
  887. #endif                    /* EventMon */
  888.  
  889.    mmsizes('=');            /* confirm region sizes */
  890.    evforget();                /* clear memory of past sizes */
  891.    }
  892.  
  893. /*
  894.  *  mmstatic() - recap the static region (stack, coexprs, aliens, free)
  895.  *   (this function is empty under FixedRegions)
  896.  */
  897. static novalue mmstatic()
  898.    {
  899. #ifndef FixedRegions
  900.    HEADER *p;
  901.    char *a;
  902.    int h;
  903.    word n;
  904.  
  905.    for (p = (HEADER *)statbase; (uword)p < (uword)(HEADER *)statfree;
  906.       p += p->s.bsize) {
  907.          a = (char *)(p + 1);
  908.          n = (p->s.bsize - 1) * sizeof(HEADER);
  909.          h = *(int *)a;
  910.          if (h == T_Coexpr)
  911.             MMStat(a, n, E_Coexpr);        /* co-expression block */
  912.          else if (h == FREEMAGIC)
  913.             MMStat(a, n, E_Free);        /* free block */
  914.          else
  915.             MMStat(a, n, E_Alien);        /* alien block */
  916.          }
  917.    a = (char *)p;
  918.    if (a < statend)
  919.       MMStat(a, (word)(statend-a), E_Free);/* rest of static region is free */
  920. #endif                    /* FixedRegions */
  921.    }
  922.  
  923. /*
  924.  * mmsizes(c) - output current region sizes, with initial character c.
  925.  * If c is '<', the unit size is written ahead of it.
  926.  */
  927. static novalue mmsizes(c)
  928. int c;
  929.    {
  930.    evnewline();
  931.  
  932. #ifdef EventMon
  933.    if (c == '<')
  934.       EVVal(C_Refresh, E_Start);
  935.    else
  936.       EVVal(C_Verify, E_Start);
  937.    fprintf(monfile, "%lu%c%lu%c%lu%c%lu%c%lu%c%lu%c%lu%c%lu%c%lu%c",
  938.       /* static region; show as full, actual amount is unknown */
  939.       (unsigned long)statbase,
  940.       E_Base,
  941.       (unsigned long)DiffPtrs(statend, statbase),
  942.       E_Used,
  943.       (unsigned long)DiffPtrs(statend, statbase),
  944.       E_Size,
  945.       /* string region */
  946.       (unsigned long)strbase,
  947.       E_Base,
  948.       (unsigned long)DiffPtrs(strfree, strbase),
  949.       E_Used,
  950.       (unsigned long)DiffPtrs(strend, strbase),
  951.       E_Size,
  952.       /* block region */
  953.       (unsigned long)blkbase,
  954.       E_Base,
  955.       (unsigned long)DiffPtrs(blkfree, blkbase),
  956.       E_Used,
  957.       (unsigned long)DiffPtrs(blkend, blkbase),
  958.       E_Size);
  959. #else                    /* EventMon */
  960.    if (c == '<')
  961.       fprintf(monfile,"%d%c\n", MMUnits, c);
  962.    else
  963.       fprintf(monfile, "%c ", c);
  964.    fprintf(monfile, "%lu:%lu/%lu %lu:%lu/%lu %lu:%lu/%lu\n",
  965.  
  966.       /* static region; show as full, actual amount is unknown */
  967.       (unsigned long)statbase,
  968.       (unsigned long)DiffPtrs(statend, statbase),
  969.       (unsigned long)DiffPtrs(statend, statbase),
  970.       /* string region */
  971.       (unsigned long)strbase,
  972.       (unsigned long)DiffPtrs(strfree, strbase),
  973.       (unsigned long)DiffPtrs(strend, strbase),
  974.       /* block region */
  975.       (unsigned long)blkbase,
  976.       (unsigned long)DiffPtrs(blkfree, blkbase),
  977.       (unsigned long)DiffPtrs(blkend, blkbase));
  978. #endif                    /* EventMon */
  979.  
  980. #ifdef EventMon
  981.    if (c == '<') {
  982.       EVVal(C_Refresh, E_End);
  983.       fprintf(monfile,"\n");
  984.       EVVal(C_Redraw, E_Start);
  985.       llen = 3;
  986.       }
  987.    else {
  988.       EVVal(C_Verify, E_End);
  989.       fprintf(monfile,"\n");
  990.       }
  991. #else                    /* EventMon */
  992.    if (c == '=')
  993.       fprintf(monfile,"\n");
  994. #endif                    /* EventMon */
  995.    }
  996.  
  997. /*
  998.  * evcmd(addr, len, c) - output a memmon command.
  999.  *  If addr is < 0, it is omitted.
  1000.  *  If len matches the previous value for command c, it is also omitted.
  1001.  *  If the output fills the line, a following newline is written.
  1002.  */
  1003.  
  1004. static novalue evcmd(addr, len, c)
  1005. word addr, len;
  1006. int c;
  1007.    {
  1008.    if (!EventStream)
  1009.       return;
  1010.    if (addr >= 0) {
  1011.       evdec((uword)addr);
  1012.       evchar(E_Offset);
  1013.       }
  1014.    etvalue(len, c);
  1015.    if (llen >= LLIM)
  1016.       evnewline();
  1017.    else
  1018.       evspace();
  1019.    }
  1020.  
  1021. /*
  1022.  * etvalue(n, c) - output length n with character c.
  1023.  * Omit the length if it matches the previous value for c.
  1024.  */
  1025. static novalue etvalue(n, c)
  1026. word n;
  1027. int c;
  1028.    {
  1029.    if (n != curvalue[c-CurBias])
  1030.       evdec((uword)(curvalue[c-CurBias] = n));
  1031.    evchar(c); 
  1032.    }
  1033.  
  1034. /*
  1035.  * evdec(n) - output a decimal value, updating the line length.
  1036.  */
  1037. static novalue evdec (n)
  1038. uword n;
  1039.    {
  1040.    if (n > 9)
  1041.       evdec(n / 10);
  1042.    n %= 10;
  1043.    evchar('0'+(int)n);
  1044.    }
  1045.  
  1046. /*
  1047.  * evnewline() - output a newline and reset the line length.
  1048.  */
  1049. static novalue evnewline()
  1050.    {
  1051.    if (llen > 0)  {
  1052.       putc('\n', monfile);
  1053.       llen = 0;
  1054.       }
  1055.    }
  1056.  
  1057. /*
  1058.  * evforget() - clear the history of remembered lengths.
  1059.  */
  1060. static novalue evforget()
  1061.    {
  1062.    int c;
  1063.  
  1064.    for (c = 0; c < CurSize; c++)
  1065.       curvalue[c] = -1;
  1066.    }
  1067.  
  1068. /*
  1069.  * EVVal(value, event) - note value produced for event
  1070.  */
  1071.  
  1072. novalue EVVal(value, event)
  1073. word value;
  1074. int event;
  1075.    {
  1076.  
  1077.    if (!EventStream)
  1078.       return;
  1079.    evcmd((word)-1, value, event);
  1080.    }
  1081. #ifdef EventMon
  1082. /*
  1083.  *  EVFnc -- write entry in function symbol table for global j
  1084.  */
  1085. novalue EVFnc(j)
  1086. word  j;
  1087.    {
  1088.    if (!EventStream)
  1089.       return;
  1090.    EVVal(j + 1, E_Pid);
  1091.    EVQval(&gnames[j], E_Sym);
  1092.    }
  1093. /*
  1094.  * EVQval -- Write quoted value from descriptor
  1095.  */
  1096. novalue EVQval(dp, j)
  1097. dptr dp;
  1098. int j;
  1099.    {
  1100.    fprintf(monfile, "\"%s\"%c\n", StrLoc(*dp), j);
  1101.    }
  1102.  
  1103.  
  1104.  
  1105. /*
  1106.  * EVValD(dp, event) - note descriptor value. For event streams, procedures
  1107.  *  get mapped into their index in the global descriptor array.  For all
  1108.  *  other types of events, they get mapped into their (event) type code.
  1109.  */
  1110.  
  1111. novalue EVValD(dp, event)
  1112. dptr dp;
  1113. int event;
  1114.    {
  1115.  
  1116.  
  1117.    if (!EventStream)
  1118.       return;
  1119.    switch (event) {
  1120.       case E_Pvan:
  1121.       case E_Pcall:
  1122.       case E_Presum:
  1123.       case E_Psusp:
  1124.       case E_Pret:
  1125.       case E_Pfail: {
  1126.          word i, j;
  1127.          /*
  1128.           * Scan the global variable array for procedures address
  1129.           */
  1130.          i = 0;
  1131.          for (j = 0; j < n_globals; j++)
  1132.             if (BlkLoc(*dp) == BlkLoc(globals[j])) {
  1133.                i = j + 1;
  1134.                break;
  1135.                }
  1136.          evcmd((word)-1, i, event);
  1137.          return;
  1138.          }
  1139.       default:
  1140.          evcmd((word)-1,TypeCode(*dp),event);
  1141.       }
  1142.    }
  1143.  
  1144. /*
  1145.  * EVValX(bp, event) - note co-expression value
  1146.  */
  1147.  
  1148. novalue EVValX(bp, event)
  1149. struct b_coexpr *bp;
  1150. int event;
  1151.    {
  1152.  
  1153.  
  1154.    if (!EventStream)
  1155.       return;
  1156.    evcmd((word)-1,bp->id,event);
  1157.    }
  1158.  
  1159. /*
  1160.  * EVInt(i) - write value of integer i to the event history file
  1161.  */
  1162.  
  1163. novalue EVInt(i)
  1164. word i;
  1165.    {
  1166.    if (!EventStream)
  1167.       return;
  1168.  
  1169.    evdec(i);
  1170.    evchar('L');            /* added for syntax confoemance */
  1171.    evseparate();
  1172.  
  1173.    }
  1174.  
  1175.  
  1176.  
  1177. #if UNIX
  1178. /*
  1179.  * EVTick() - record a Tick event reflecting a clock advance.
  1180.  *
  1181.  *  The interpreter main loop has detected a change in the profile counters.
  1182.  *  This means that the system clock has ticked.  Record an event and update
  1183.  *  the records.
  1184.  */
  1185. static word oldsum = 0;
  1186.  
  1187. novalue EVTick()
  1188.    {
  1189.    word sum, nticks;
  1190.  
  1191.    oldtick = ticker.l[0] + ticker.l[1];
  1192.    sum = ticker.s[0] + ticker.s[1] + ticker.s[2] + ticker.s[3];
  1193.    nticks = sum - oldsum;
  1194.    EVVal(nticks, E_Tick);
  1195.    oldsum = sum;
  1196.    }
  1197. #endif                    /* UNIX */
  1198. #endif                    /* EventMon */
  1199.  
  1200. #else                    /* MemMon */
  1201. static char x;            /* avoid empty module */
  1202. #endif                    /* MemMon */
  1203.